{-# LANGUAGE TemplateHaskell,ScopedTypeVariables #-}
module PolicyT where

import Language.Haskell.TH
import Data.List
import Control.Monad
import Data.Bits

import Debug.Trace

type Policy = Int

data Management = SimpleM Policy Policy Policy
  deriving Show


class RandTree a where
  maxn :: a -> Int
  pick :: Int -> a -> a

{-

  subst :: Int -> a -> a -> a
  maxa :: a -> Int
  alternate :: Int -> a -> a
-}

data T1 = T1
data T2 a = T2 a

deriveRandTree ts = do
  -- Get list of constructors for type t
  tcl <- mapM reify ts
  d <- [d| instance RandTree T1 where
                    maxn x = 0
                    pick x y = T1 |]
  let cons = [typename | TyConI (DataD _ typename _ cs _) <- tcl ]
  let maxnClause prefix (NormalC name fields) = do
        (pats,vars) <- genPE (length fields)
        let body = (normalB (litE (integerL (fromIntegral (length vars)))))
        clause [conP name pats] body []  -- "A "++show x1++" "++show x2
  let pickClause prefix i (NormalC name fields) = do
        (pats,vars) <- genPE (length fields)
        let body = (normalB (sfcall (conE name) vars))
        clause [litP (integerL (fromIntegral i)),
                conP name pats] body []  -- "A "++show x1++" "++show x2
  let randTreeM prefix constructors = do
       maxnbody <- mapM (maxnClause prefix) constructors
       pickbody <- mapM (pickClause prefix 14) constructors
       let [InstanceD [] (AppT randtree_t (ConT _T1)) [FunD maxnf _text,
                                                       FunD pickf _text2]] = d
       let res = [InstanceD [] (AppT randtree_t (ConT prefix  )) [FunD maxnf maxnbody,
                                                                  FunD pickf pickbody ]]
       return res
  let pnodeEntry n = [normalC (mkName ("PNP"++(nameBase n))) [strictType notStrict (conT n)]]
  let pnodeBody :: [ConQ] = (concat) $ map pnodeEntry cons
  b <- [d| data PNode 
             = PNP Policy 
       |]
  let [DataD [] pnode [] (_pnodeBodyf) [] ] = b
  sequence [dataD (cxt []) pnode [] pnodeBody []]
  
   

-- Generate n unique variables and return them in form of patterns and expressions
genPE n = do
  ids <- replicateM n (newName "x")
  return (map varP ids, map varE ids)

buildCP :: Name -> Int -> Int -> ExpQ
buildCP ctor nVars id = 
    do let rawnames = map (bitToExprs id) [0 .. (nVars - 1)] 
       let (p3,p1,p2) = unzip3 rawnames
       return $ LamE [ConP ctor p1, ConP ctor p2] (fcall (ConE ctor) p3)

fcall f [] = f
fcall f (x:xs) = fcall (AppE (f) x) xs

sfcall f [] = f
sfcall f (x:xs) = sfcall (appE (f) x) xs

-- There is also a template haskell [p| ... |] syntax, but not yet implemented ...
bitToExprs:: Int -> Int -> (Exp,Pat,Pat)
bitToExprs k n =
    if Data.Bits.testBit (k::Int) (n::Int) -- is nth bit of k == 1
    then (e,v1,v2)
    else (e,v2,v1)
    where v1 = WildP
          v2 = VarP (mkName name)
          e = VarE (mkName name)
          name = "d" ++ (show $ n + 1)


-- bcp k = [d| cp0 0 = $(buildCP 'SimpleM 3 k) |]

bcp' = (liftM concat)$ sequence [ (bcp k) | k <- [0..7] ]

bcp k = do bcx <- (buildCP 'SimpleM 3 k)
           return [ FunD cp0 [Clause [LitP (IntegerL (fromIntegral k))] 
                              (NormalB bcx)
                              []
                             ]
                  ]
    where cp0 = (mkName "cp0")
